functor DeadCode (S : DEADCODE_STRUCTS) : DEADCODE =
struct
  open S
  
  
  structure Cfg = Cfg
  
  local open Cfg
  in structure Id = Id
     structure Intl = Intl
     structure T = Types
     structure B = Binop
     structure O = Operand
     structure K = Block
     structure S = Structs
     structure J = Transfer
     structure M = Stm
     structure F = Function
     structure P = Program
  end
  
  val tag = !Control.doShowOptVerbose
  fun debugPrint s =
      if tag
      then print s
      else ()
      
  structure Pool : 
  sig
    val add : Id.t -> unit
    val isEmpty : unit -> bool
    val remove : unit -> Id.t
  end =
  struct
    val all : Id.t list ref = ref []
    
    fun add x = all := x :: (!all)
    fun isEmpty () =
        case !all
         of [] => true
          | _ => false    
   
    fun remove () =
        case !all
         of [] => raise Fail "compiler bug"
          | x :: xs =>
            let val _ = all := xs
            in  x
            end          
  end
  
  structure CounterSet =
  BinarySetFn (struct
                 type ord_key = Counter.t
                 val compare = Counter.compare
               end)
               
  structure Set :
  sig
    type t
    
    val add : t * Counter.t -> t
    val delete : t * Counter.t -> t
    val empty : unit -> t
    val isEmpty : t -> bool
    val member : t * Counter.t -> bool
  end =
  struct
    type t = CounterSet.set
    
    fun add (set, id) = CounterSet.add (set, id)    
    fun empty () = CounterSet.empty
    val isEmpty = CounterSet.isEmpty
    fun member (set, id) = CounterSet.member (set, id)
    fun delete (set, id) =
        if member (set, id)
        then CounterSet.delete (set, id)
        else set
  end
               
  val {get = useSites, set = setUseSites, destroy = destroyUseSites, ...} :
      {get : Id.t -> Set.t, set : Id.t * Set.t -> unit, destroy : unit -> unit} =
      Property.destGetSet (Id.plist, Property.initConst (Set.empty ()))
  
  fun takeAllVars vars = List.app Pool.add vars
  
  fun initUseStm (id, s) =
      if M.usesId (s, id)
      then let val line = M.getLine s
               val oldSet = useSites id
               val newSet = Set.add (oldSet, line)
               val _ = setUseSites (id, newSet)
           in  ()
           end
      else ()
      
  fun initUseTransfer (id, s) =
      if J.usesId (s, id)
      then let val line = J.getLine s
               val oldSet = useSites id
               val newSet = Set.add (oldSet, line)
               val _ = setUseSites (id, newSet)
           in  ()
           end
      else ()
      
  fun initUseSitesOneVarOneBlock (id, b) =
      case b
       of K.T {name,
               prop,
               stms,
               transfer,
               successors} =>
          let val _ = List.app (fn s => initUseStm (id, s)) stms 
              val _ = initUseTransfer (id, transfer)
          in  ()
          end
       
  fun initUseSitesOneVar (x, blocks) =
      List.app (fn b => initUseSitesOneVarOneBlock (x, b)) blocks
        
  fun initUseSites (vars, blocks) =
      List.app (fn x => initUseSitesOneVar (x, blocks)) vars
      
  fun loop (blocks) =
      let fun doStm (id, s) =
              if M.withSideEffects s
              then [s]
              else let val allVars = M.uses s
                       val counter = M.getLine s
                       fun deleteOne var =
                           let val oldSites = useSites var
                               val newSites = Set.delete (oldSites, counter)
                               val _ = setUseSites (var, newSites)
                               val _ = Pool.add var
                           in  ()
                           end
                       fun delete vars =
                           List.app deleteOne vars
                       val _ = delete allVars                       
                   in  []
                   end              
          fun doStms (id, stms) =
          case stms
           of [] => []
            | x :: xs =>
              let val def = M.cookDest x
              in  case def
                   of NONE => x :: (doStms (id, xs))
                    | SOME id' =>
                      if Id.equals (id, id')
                      then doStm (id, x) @ (doStms (id, xs))
                      else x :: (doStms (id, xs))
              end
          fun doBlock (id, b) =
              case b
               of K.T {name,
                               prop,
                               stms,
                               transfer,
                               successors} =>
              let val newStms = doStms (id, stms)
                  val new = K.T {name = name,
                                 prop = prop,
                                 stms = newStms,
                                 transfer = transfer,
                                 successors = successors}
              in  new
              end    
          fun doBlocks (id, blocks) =
              List.map (fn b => doBlock (id, b)) blocks
      in  if Pool.isEmpty ()
          then blocks
          else let val id = Pool.remove ()
                   val sites = useSites id
                   val new = 
                       if Set.isEmpty sites
                       then doBlocks (id, blocks)
                       else blocks
               in  loop new
               end
      end
          
  
  fun shrinkFunc f =
      case f
       of F.T {name,
               exit,
                rettype,
                args,
                locals,
                blocks,
                pre,
                post} =>
          let val allVars = List.map #id (args @ locals)
              val _ = takeAllVars allVars
              val _ = initUseSites (allVars, blocks)
              val newBlocks = loop blocks
              val new = F.T {name = name,
                             exit = exit,
                             rettype = rettype,
                             args = args,
                             locals = locals,
                             blocks = newBlocks,
                             pre = pre,
                             post = post}
              val _ = debugPrint "\noutput the graph after dead code\n"
              val _ = if tag
                      then F.toDot (new, "afterDeadCode")
                      else ()
              val _ = destroyUseSites ()
          in  new
          end
  
  fun shrinkProg f =
      case f
       of P.T {structs, gvars, funcs, ...} =>
          let val _ = ()
          in  P.T {structs = structs,
                   gvars = gvars,
                   funcs = List.map shrinkFunc funcs}
          end
  
  fun shrink f=
      let val _ = debugPrint "\ndead code starting\n"
          val new = shrinkProg f
          val _ = debugPrint "\ndead code finished\n"
      in  new
      end
end
